home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue58 / EasyWeb / Enhcalnd.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-03-27  |  27.0 KB  |  880 lines
  1. { *****************************************************
  2.               TCalendarLabel Component
  3.  
  4.   The TRngSelCalendar component is an improved version of the
  5.   calendar provided on the Samples page of Delphi 1.02.
  6.   Improvements include the ability to store strings in
  7.   the cells, provide foreground color for occupied cells
  8.   and drag/drop abilities.
  9.  
  10.   The TCalendarLabel component attaches to a TRngSelCalendar and
  11.   displays the month and year. TCalLabel responds to the
  12.   HookEvent event. See unit EList.pas for details.
  13.  
  14.                   Paul Warren
  15.          HomeGrown Software Development
  16.        (c) 1997 Langley British Columbia.
  17.                 (604) 856-6523
  18.          e-mail:  hg_soft@uniserve.com
  19.     Home page: http://users.uniserve.com/~hg_soft
  20.   ***************************************************** }
  21.  
  22. unit Enhcalnd;
  23.  
  24. interface
  25.  
  26. uses
  27.   {$IFDEF WIN32}
  28.   Windows,
  29.   {$ELSE}
  30.   Wintypes, WinProcs,
  31.   {$ENDIF}
  32.   Classes, Controls, Messages, Forms, Graphics, StdCtrls,
  33.      Grids, SysUtils, Menus, ExtCtrls, EList;
  34.  
  35. type
  36.   TDayOfWeek = 0..6;
  37.  
  38.   TMonthChange = procedure(Sender: TObject; Month: Integer) of object;
  39.   TYearChange = procedure(Sender: TObject; Year: Integer) of object;
  40.   TDateChange = procedure(Sender: TObject; NewDate: TDateTime) of object;
  41.   TDroppedCell = procedure(Sender: TObject; ACol, ARow: LongInt;
  42.     var Value: string) of object;
  43.   TCellDragOver = procedure(Sender, Source: TObject; X, Y: Integer;
  44.     State: TDragState; var Accept: Boolean) of object;
  45.  
  46.   TBaseCalendar = class(TCustomGrid)
  47.   private
  48.     { Private declarations }
  49.     FBlockWeekends: Boolean;
  50.     FBlockedColor: TColor;
  51.     FDate: TDateTime;
  52.     FFixedHeader: Boolean;
  53.     FMonthOffset: Integer;
  54.     FReadOnly: Boolean;
  55.     FStartOfWeek: TDayOfWeek;
  56.     FUpdating: Boolean;
  57.     FMonthChange: TMonthChange;
  58.     FYearChange: TYearChange;
  59.     FDateChange: TDateChange;
  60.     FEventList: TEventList;
  61.     FHookEvent: TNotifyEvent;
  62.     function GetCellText(ACol, ARow: Integer): string;
  63.     function GetDateElement(Index: Integer): Integer;
  64.     procedure SetBlockWeekends(Value: Boolean);
  65.     procedure SetBlockedColor(Value: TColor);
  66.     procedure SetCalendarDate(Value: TDateTime);
  67.     procedure SetDateElement(Index: Integer; Value: Integer);
  68.     procedure SetFixedHeader(Value: Boolean);
  69.     procedure SetStartOfWeek(Value: TDayOfWeek);
  70.     procedure SetHookEvent(Value: TNotifyEvent);
  71.   protected
  72.     { Protected declarations }
  73.     procedure Loaded; override;
  74.     procedure Click; override;
  75.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  76.     function DaysPerMonth(AYear, AMonth: Integer): Integer; virtual;
  77.     function IsLeapYear(AYear: Integer): Boolean; virtual;
  78.     function SelectCell(ACol, ARow: Longint): Boolean; override;
  79.   public
  80.     { Public declarations }
  81.     constructor Create(AOwner: TComponent); override;
  82.     destructor Destroy; override;
  83.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  84.     procedure NextMonth;
  85.     procedure NextYear;
  86.     procedure PrevMonth;
  87.     procedure PrevYear;
  88.     function DaysThisMonth: Integer;
  89.     function IsWeekend(ADay: integer): boolean;
  90.     procedure UpdateCalendar; virtual;
  91.     function GetComponentImage: TBitmap;
  92.     procedure MouseToCell(X, Y: Integer; var ACol, ARow: Longint);
  93.     property CellText[ACol, ARow: Integer]: string read GetCellText;
  94.     property CalendarDate: TDateTime read FDate write SetCalendarDate stored false;
  95.     property Day: Integer index 3 read GetDateElement write SetDateElement stored false;
  96.     property Month: Integer index 2  read GetDateElement write SetDateElement stored false;
  97.     property Year: Integer index 1  read GetDateElement write SetDateElement stored false;
  98.     property BlockWeekends: Boolean read FBlockWeekends write SetBlockWeekends default false;
  99.     property BlockedColor: TColor read FBlockedColor write SetBlockedColor default clGray;
  100.     property FixedHeader: Boolean read FFixedHeader write SetFixedHeader default True;
  101.     property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
  102.     property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek;
  103.     property OnDateChange: TDateChange read FDateChange write FDateChange;
  104.     property OnMonthChange: TMonthChange read FMonthChange write FMonthChange;
  105.     property OnYearChange: TYearChange read FYearChange write FYearChange;
  106.     property HookEvent: TNotifyEvent write SetHookEvent;
  107.   published
  108.     { Published declarations }
  109.   end;
  110.  
  111.   TCalendarStrings = array[0..6, 0..6] of TStringList;
  112.   TNeedStrings = procedure(Sender: TObject; ACol, ARow: LongInt;
  113.     ADate: TDateTime; var Value: TStringList) of object;
  114.  
  115.   TStringsCalendar = class(TBaseCalendar)
  116.   private
  117.     { Private declarations }
  118.     FCalStrings: TCalendarStrings;
  119.     FOnDroppedCell: TDroppedCell;
  120.     FOnCellDragOver: TCellDragOver;
  121.     FOnNeedStrings: TNeedStrings;
  122.     function GetCalStrings(ACol, ARow: integer): TStringList; virtual;
  123.     procedure SetCalStrings(ACol, ARow: Integer; Value: TStringList); virtual;
  124.     procedure SetCellString(ACol, ARow, ADay: Integer; Value: string); virtual;
  125.   protected
  126.     { Protected declarations }
  127.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  128.     procedure AcceptDropped(Sender, Source: TObject; X, Y: integer);
  129.     procedure CellDragOver(Sender, Source: TObject; X, Y: Integer;
  130.       State: TDragState; var Accept: Boolean);
  131.   public
  132.     { Public declarations }
  133.     constructor Create(AOwner: TComponent); override;
  134.     destructor Destroy; override;
  135.     procedure ClearAllDays;
  136.     property CellString[ACol, ARow, ADay: Integer]: string write SetCellString;
  137.     property CalStrings[ACol, ARow: Integer]: TStringList read GetCalStrings write SetCalStrings;
  138.   published
  139.     { Published declarations }
  140.     property OnDroppedCell: TDroppedCell read FOnDroppedCell write FOnDroppedCell;
  141.     property OnCellDragOver: TCellDragOver read FOnCellDragOver write FOnCellDragOver;
  142.     property OnNeedStrings: TNeedStrings read FOnNeedStrings write FOnNeedStrings;
  143.     property BlockWeekends;
  144.     property BlockedColor;
  145.     property FixedHeader;
  146.     property ReadOnly;
  147.     property StartOfWeek;
  148.     property OnDateChange;
  149.     property OnMonthChange;
  150.     property OnYearChange;
  151.     property Align;
  152.     property BorderStyle;
  153.     property Color;
  154.     property Ctl3D;
  155.     property DragCursor;
  156.     property DragMode;
  157.     property Enabled;
  158.     property FixedColor;
  159.     property Font;
  160.     property ParentColor;
  161.     property ParentCtl3D;
  162.     property ParentFont;
  163.     property ParentShowHint;
  164.     property PopupMenu;
  165.     property ShowHint;
  166.     property TabOrder;
  167.     property TabStop;
  168.     property Visible;
  169.     property OnClick;
  170.     property OnDblClick;
  171.     property OnEndDrag;
  172.     property OnEnter;
  173.     property OnExit;
  174.     property OnKeyDown;
  175.     property OnKeyPress;
  176.     property OnKeyUp;
  177.     property OnMouseDown;
  178.     property OnMouseMove;
  179.     property OnMouseUp;
  180.   end;
  181.  
  182.   TRngSelCalendar = class(TStringsCalendar)
  183.   private
  184.     { private declarations }
  185.     FRangeColor: TColor;
  186.     FStartDate: TDateTime;
  187.     FEndDate: TDateTime;
  188.     FOnRngSelect: TNotifyEvent;
  189.     procedure SetStartDate(Value: TDateTime);
  190.     procedure SetEndDate(Value: TDateTime);
  191.   protected
  192.     { protected declarations }
  193.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  194.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  195.   public
  196.     { public declarations }
  197.     constructor Create(AOwner: TComponent); override;
  198.     property StartDate: TDateTime read FStartDate write SetStartDate;
  199.     property EndDate: TDateTime read FEndDate write SetEndDate;
  200.   published
  201.     { published declarations }
  202.     property RangeColor: TColor read FRangeColor write FRangeColor default clBlue;
  203.     property OnRngSelect: TNotifyEvent read FOnRngSelect write FOnRngSelect;
  204.   end;
  205.   TCalendarLabel = class(TLabel)  private
  206.     { private declarations }
  207.     FCalendarSource: TStringsCalendar;
  208.     procedure SetSource(Value: TStringsCalendar);
  209.   protected
  210.     { protected declarations }
  211.     procedure Notification(AComponent: TComponent;
  212.       Operation: TOperation); override;
  213.     procedure DateChange(Sender: TObject);
  214.   public
  215.     { public declarations }
  216.     procedure Loaded; override;
  217.     procedure UpdateLabel;
  218.   published
  219.     { published declarations }
  220.     property CalendarSource: TStringsCalendar read FCalendarSource write SetSource;
  221.   end;
  222.  
  223. implementation
  224.  
  225. {$IFDEF WIN32}
  226.   {$R ENHCALND.D32}
  227. {$ELSE}
  228.   {$R ENHCALND.D16}
  229. {$ENDIF}
  230.  
  231. { TBaseCalendar }
  232. constructor TBaseCalendar.Create(AOwner: TComponent);
  233. begin
  234.   inherited Create(AOwner);
  235.   { defaults }
  236.   ColCount := 7;
  237.   FixedCols := 0;
  238.   FixedRows := 1;
  239.   Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  240.   RowCount := 7;
  241.   ScrollBars := ssNone;
  242.   FBlockWeekends := false;
  243.   FBlockedColor := clGray;
  244.   FDate := Date;
  245.   FFixedHeader := true;
  246.   FEventList := TEventList.Create;
  247. end;
  248.  
  249. destructor TBaseCalendar.Destroy;
  250. begin
  251.   FEventList.Free;
  252.   inherited Destroy;
  253. end;
  254.  
  255. { Loaded override }
  256. procedure TBaseCalendar.Loaded;
  257. begin
  258.   inherited Loaded;
  259.   UpdateCalendar;
  260. end;
  261.  
  262. { Click override - sets day to the cell clicked }
  263. procedure TBaseCalendar.Click;
  264. var
  265.   TheCellText: string;
  266. begin
  267.   TheCellText := CellText[Col, Row];
  268.   if TheCellText <> '' then Day := StrToInt(TheCellText);
  269.   inherited Click;
  270. end;
  271.  
  272. { IsLeapYear - support routine }
  273. function TBaseCalendar.IsLeapYear(AYear: Integer): Boolean;
  274. begin
  275.   Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
  276. end;
  277.  
  278. { DaysPerMonth - protected implementation of DaysThisMonth }
  279. function TBaseCalendar.DaysPerMonth(AYear, AMonth: Integer): Integer;
  280. const
  281.   DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  282. begin
  283.   Result := DaysInMonth[AMonth];
  284.   if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
  285. end;
  286.  
  287. { DaysThisMonth - support routine to return the days in the current month }
  288. function TBaseCalendar.DaysThisMonth: Integer;
  289. begin
  290.   Result := DaysPerMonth(Year, Month);
  291. end;
  292.  
  293. { IsWeekend - support routine to determine if a given day is a weekend }
  294. function TBaseCalendar.IsWeekend(ADay: integer): boolean;
  295. var
  296.   i, j: integer;
  297.   TheCellText: string;
  298. begin
  299.   Result := false;
  300.   for i := 0 to 6 do
  301.     for j := 1 to 6 do
  302.     begin
  303.       TheCellText := CellText[i, j];
  304.       if (TheCellText <> '') and (ADay = StrToInt(TheCellText)) then
  305.         if (i = 0) or (i = 6) then
  306.           Result := true
  307.         else Result := false;
  308.     end;
  309. end;
  310.  
  311. { MouseToCell - support routine to convert the mouse position
  312.   to cell coords }
  313. procedure TBaseCalendar.MouseToCell(X, Y: Integer; var ACol, ARow: Longint);
  314. var
  315.   Coord: TGridCoord;
  316. begin
  317.   Coord := MouseCoord(X, Y);
  318.   ACol := Coord.X;
  319.   ARow := Coord.Y;
  320. end;
  321.  
  322. { DrawCell override }
  323. procedure TBaseCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
  324. var
  325.   TheText: string;
  326. begin
  327.   TheText := CellText[ACol, ARow];
  328.   if ((ACol = 0) or (ACol = 6)) and FBlockWeekends and (TheText <> '') and (ARow <> 0) then
  329.     Canvas.Brush.Color := BlockedColor;
  330.   with ARect, Canvas do
  331.     TextRect(ARect, (Left + 1), (Top + 1), TheText);
  332. end;
  333.  
  334. { GetCellText - property access method to return the selected date
  335.   as a string. Acts as a storage device for the dates }
  336. function TBaseCalendar.GetCellText(ACol, ARow: Integer): string;
  337. var
  338.   DayNum: Integer;
  339. begin
  340.   if ARow = 0 then  { day names at tops of columns }
  341.     Result := ShortDayNames[(StartOfWeek + ACol) mod 7 + 1]
  342.   else
  343.   begin
  344.     DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
  345.     if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := ''
  346.     else Result := IntToStr(DayNum);
  347.   end;
  348. end;
  349.  
  350. { SelectCell override - returns false for cells that shouldn't be
  351.   selected }
  352. function TBaseCalendar.SelectCell(ACol, ARow: Longint): Boolean;
  353. begin
  354.   Result := inherited SelectCell(ACol, ARow);
  355.   if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') then
  356.       Result := False;
  357.   if FBlockWeekends and ((ACol = 0) or (ACol = 6)) then
  358.       Result := False;
  359. end;
  360.  
  361. { SetCalendarDate - property access method to set calendar focused date }
  362. procedure TBaseCalendar.SetCalendarDate(Value: TDateTime);
  363. begin
  364.   if Value <> FDate then
  365.   begin
  366.     FDate := Value;
  367.     UpdateCalendar;
  368.   end;
  369. end;
  370.  
  371. { SetDateElement - internal method to get day, month or year }
  372. function TBaseCalendar.GetDateElement(Index: Integer): Integer;
  373. var
  374.   AYear, AMonth, ADay: Word;
  375. begin
  376.   DecodeDate(FDate, AYear, AMonth, ADay);
  377.   case Index of
  378.     1: Result := AYear;
  379.     2: Result := AMonth;
  380.     3: Result := ADay;
  381.     else Result := -1;
  382.   end;
  383. end;
  384.  
  385. { SetDateElement - internal method to set day, month or year }
  386. procedure TBaseCalendar.SetDateElement(Index: Integer; Value: Integer);
  387. var
  388.   AYear, AMonth, ADay: Word;
  389. begin
  390.   if Value > 0 then
  391.   begin
  392.     DecodeDate(FDate, AYear, AMonth, ADay);
  393.     case Index of
  394.       1: if AYear <> Value then AYear := Value else Exit;
  395.       2: if (Value <= 12) and (Value <> AMonth) then AMonth := Value else Exit;
  396.       3: if (Value <= DaysThisMonth) and (Value <> ADay) then ADay := Value else Exit;
  397.       else Exit;
  398.     end;
  399.     if ADay > DaysPerMonth(AYear, AMonth) then ADay := DaysPerMonth(AYear, AMonth);
  400.     FDate := EncodeDate(AYear, AMonth, ADay);
  401.     UpdateCalendar;
  402.   end;
  403. end;
  404.  
  405. { SetHookEvent - property access method to attach a HookEvent }
  406. procedure TBaseCalendar.SetHookEvent(Value: TNotifyEvent);
  407. begin
  408.   FEventList.AddEvent(Value);
  409. end;
  410.  
  411. { SetStartOfWeek - property access method to change the starting
  412.   day of the week. }
  413. procedure TBaseCalendar.SetStartOfWeek(Value: TDayOfWeek);
  414. begin
  415.   if Value <> FStartOfWeek then
  416.   begin
  417.     FStartOfWeek := Value;
  418.     UpdateCalendar;
  419.   end;
  420. end;
  421.  
  422. { SetFixedHeader - property access method to toggle fixed header }
  423. procedure TBaseCalendar.SetFixedHeader(Value: Boolean);
  424. begin
  425.   FFixedHeader := Value;
  426.   SetBounds(Left, Top, Width, Height);
  427. end;
  428.  
  429. { SetBlockWeekends - property access method to toggle
  430.   weekend blocking. }
  431. procedure TBaseCalendar.SetBlockWeekends(Value: Boolean);
  432. begin
  433.   if Value <> FBlockWeekends then
  434.   begin
  435.     FBlockWeekends := Value;
  436.     Invalidate;
  437.   end;
  438. end;
  439.  
  440. { SetBlockedColor - property access method to set the color for
  441.   blocked days. clSilver doesn't look good. }
  442. procedure TBaseCalendar.SetBlockedColor(Value: TColor);
  443. begin
  444.   if Value <> FBlockedColor then
  445.   begin
  446.     FBlockedColor := Value;
  447.     Invalidate;
  448.   end;
  449. end;
  450.  
  451. { PrevMonth }
  452. procedure TBaseCalendar.PrevMonth;
  453. begin
  454.   if Month > 1 then Month := pred(Month)
  455.   else begin
  456.     Year := Year - 1;
  457.     Month := 12;
  458.   end;
  459.   if Assigned(FMonthChange) then FMonthChange(Self, Month);
  460. end;
  461.  
  462. { NextMonth }
  463. procedure TBaseCalendar.NextMonth;
  464. begin
  465.   if Month < 12 then Month := succ(Month)
  466.   else begin
  467.     Year := Year + 1;
  468.     Month := 1;
  469.   end;
  470.   if Assigned(FMonthChange) then FMonthChange(Self, Month);
  471. end;
  472.  
  473. { NextYear }
  474. procedure TBaseCalendar.NextYear;
  475. begin
  476.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  477.   Year := Year + 1;
  478.   if Assigned(FYearChange) then FYearChange(Self, Year);
  479. end;
  480.  
  481. { PrevYear }
  482. procedure TBaseCalendar.PrevYear;
  483. begin
  484.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  485.   Year := Year - 1;
  486.   if Assigned(FYearChange) then FYearChange(Self, Year);
  487. end;
  488.  
  489. { UpdateCalendar - central "engine" }
  490. procedure TBaseCalendar.UpdateCalendar;
  491. var
  492.   AYear, AMonth, ADay: Word;
  493.   FirstDate: TDateTime;
  494.   i: integer;
  495. begin
  496.   FUpdating := True;
  497.   try
  498.     DecodeDate(FDate, AYear, AMonth, ADay);
  499.     FirstDate := EncodeDate(AYear, AMonth, 1);
  500.     { day of week for 1st of month }
  501.     FMonthOffset := 2 - ((DayOfWeek(FirstDate) - FStartOfWeek + 7) mod 7);
  502.     if FMonthOffset = 2 then FMonthOffset := -5;
  503.     MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1,
  504.       False, False);
  505.     Invalidate;
  506.     { trigger OnDateChange and all HookEvents }
  507.     if Assigned(FDateChange) then FDateChange(Self, FDate);
  508.     for i := 0 to FEventList.Count-1 do
  509.     begin
  510.       FHookEvent := FEventList.Events[i];
  511.       FHookEvent(Self);
  512.     end;
  513.   finally
  514.     FUpdating := False;
  515.   end;
  516. end;
  517.  
  518. procedure TBaseCalendar.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  519. var
  520.   FixedSize: integer;
  521.   GridLines: Integer;
  522. begin
  523.   GridLines := 6 * GridLineWidth;
  524.   { set size of title row }
  525.   FixedSize := Font.Size + 8;
  526.   DefaultColWidth  := (AWidth  - GridLines) div 7;
  527.   if FFixedHeader then
  528.   begin
  529.     DefaultRowHeight := ((AHeight - FixedSize) - GridLines) div 6;
  530.     {$IFDEF WIN32}
  531.     AHeight := (((DefaultRowHeight + GridLineWidth) * 6) + 4 + (FixedSize + GridLineWidth));
  532.     {$ELSE}
  533.     AHeight := (((DefaultRowHeight + GridLineWidth) * 6) + 2 + (FixedSize + GridLineWidth));
  534.     {$ENDIF}
  535.     RowHeights[0] := FixedSize;
  536.   end else begin
  537.     DefaultRowHeight := (AHeight - GridLines) div 7;
  538.     {$IFDEF WIN32}
  539.     AHeight := (((DefaultRowHeight + GridLineWidth) * 7) + 4);
  540.     {$ELSE}
  541.     AHeight := (((DefaultRowHeight + GridLineWidth) * 7) + 2);
  542.     {$ENDIF}
  543.   end;
  544.   {$IFDEF WIN32}
  545.   AWidth := (((DefaultColWidth + GridLineWidth) * 7) + 4);
  546.   {$ELSE}
  547.   AWidth := (((DefaultColWidth + GridLineWidth) * 7) + 2);
  548.   {$ENDIF}
  549.   inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  550. end;
  551.  
  552. { GetComponentImage - method to turn on-screen rendering into a bitmap.
  553.   Allows easy printing }
  554. {$IFDEF WIN32}
  555. function TBaseCalendar.GetComponentImage: TBitmap;
  556. begin
  557.   Result := TBitmap.Create;
  558.   try
  559.     Result.Width := ClientWidth+1;
  560.     Result.Height := ClientHeight+1;
  561.     Result.Canvas.Brush := Brush;
  562.     Result.Canvas.FillRect(ClientRect);
  563.     Result.Canvas.Lock;
  564.     try
  565.       PaintTo(Result.Canvas.Handle, -1, -1);
  566.     finally
  567.       Result.Canvas.Unlock;
  568.     end;
  569.   except
  570.     Result.Free;
  571.     raise;
  572.   end;
  573. end;
  574. {$ELSE}
  575. function TBaseCalendar.GetComponentImage: TBitmap;
  576. var
  577.   ScreenDC, PrintDC: HDC;
  578.   OldBits, PrintBits: HBITMAP;
  579.   PaintLParam: Longint;
  580.  
  581.   procedure PrintHandle(Handle: HWND);
  582.   var
  583.     R: TRect;
  584.     SavedIndex: Integer;
  585.   begin
  586.     SavedIndex := SaveDC(PrintDC);
  587.     WinProcs.GetClientRect(Handle, R);
  588.     MapWindowPoints(Handle, Self.Handle, R, 2);
  589.     with R do
  590.     begin
  591.       SetWindowOrgEx(PrintDC, -Left, -Top, nil);
  592.       IntersectClipRect(PrintDC, 0, 0, Right - Left, Bottom - Top);
  593.     end;
  594.     SendMessage(Handle, WM_ERASEBKGND, PrintDC, 0);
  595.     SendMessage(Handle, WM_PAINT, PrintDC, PaintLParam);
  596.     RestoreDC(PrintDC, SavedIndex);
  597.   end;
  598.  
  599. begin
  600.   Result := nil;
  601.   ScreenDC := GetDC(0);
  602.   PaintLParam := 0;
  603.   try
  604.     PrintDC := CreateCompatibleDC(ScreenDC);
  605.     { Work around an apparent bug in Windows NT }
  606.     if GetWinFlags and $4000 <> 0 then PaintLParam := PrintDC or $DEFE0000;
  607.     try
  608.       PrintBits := CreateCompatibleBitmap(ScreenDC, ClientWidth, ClientHeight);
  609.       try
  610.         OldBits := SelectObject(PrintDC, PrintBits);
  611.         try
  612.           { Clear the contents of the bitmap }
  613.           FillRect(PrintDC, ClientRect, Brush.Handle);
  614.  
  615.           { Paint form into a bitmap }
  616.           PrintHandle(Handle);
  617.         finally
  618.           SelectObject(PrintDC, OldBits);
  619.         end;
  620.         Result := TBitmap.Create;
  621.         Result.Handle := PrintBits;
  622.         PrintBits := 0;
  623.       except
  624.         Result.Free;
  625.         if PrintBits <> 0 then DeleteObject(PrintBits);
  626.         raise;
  627.       end;
  628.     finally
  629.       DeleteDC(PrintDC);
  630.     end;
  631.   finally
  632.     ReleaseDC(0, ScreenDC);
  633.   end;
  634. end;
  635. {$ENDIF}
  636.  
  637. { TStringsCalendar }
  638. constructor TStringsCalendar.Create(AOwner: TComponent);
  639. begin
  640.   inherited Create(AOwner);
  641.   { clear cells - reason: explicitly set to nil
  642.     to avoid problems later }
  643.   ClearAllDays;
  644.   { set drag methods }
  645.   OnDragDrop := AcceptDropped;
  646.   OnDragOver := CellDragOver;
  647. end;
  648.  
  649. destructor TStringsCalendar.Destroy;
  650. begin
  651.   { clear cells }
  652.   ClearAllDays;
  653.   inherited Destroy;
  654. end;
  655.  
  656. { ClearAllDays - method to clear cells }
  657. procedure TStringsCalendar.ClearAllDays;
  658. var
  659.   i, j: integer;
  660. begin
  661.   {iterate through array and free all StringLists }
  662.   for i := 0 to 6 do
  663.     for j := 0 to 6 do
  664.     begin
  665.       FCalStrings[i, j].Free;
  666.       { explicitly set to nil or else... }
  667.       FCalStrings[i, j] := nil;
  668.     end;
  669.   UpdateCalendar;
  670. end;
  671.  
  672. { AcceptDropped override }
  673. procedure TStringsCalendar.AcceptDropped(Sender, Source: TObject; X, Y: integer);
  674. var
  675.   ACol, ARow: LongInt;
  676.   Value: string;
  677. begin
  678.   { convert X and Y to Col and Row for convenience }
  679.   MouseToCell(X, Y, ACol, ARow);
  680.   { let user respond to event }
  681.   if Assigned(FOnDroppedCell) then FOnDroppedCell(Source, ACol, ARow, Value);
  682.   { if user returns a string add it to the cells list }
  683.   if Value <> '' then SetCellString(ACol, ARow, 0, Value);
  684.   { set focus to calendar }
  685.   SetFocus;
  686.   { force redraw }
  687.   Invalidate;
  688. end;
  689.  
  690. { CellDragOver override }
  691. procedure TStringsCalendar.CellDragOver(Sender, Source: TObject; X, Y: Integer;
  692.       State: TDragState; var Accept: Boolean);
  693. var
  694.   ACol, ARow: LongInt;
  695. begin
  696.   { convert X and Y to Col and Row for convenience }
  697.   MouseToCell(X, Y, ACol, ARow);
  698.   { allow user to set Accept the way they want }
  699.   if Assigned(FOnCellDragOver) then FOnCellDragOver(Sender, Source, ACol, ARow, State, Accept);
  700.   { if Accept = true then apply further logic else leave Accept = false }
  701.   if Accept = true then
  702.     if (not FUpdating) and (not FReadOnly) and (CellText[ACol, ARow] <> '') then
  703.       Accept := true
  704.     else Accept := false;
  705. end;
  706.  
  707. { DrawCell }
  708. procedure TStringsCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
  709. var
  710.   Temp: TStringList;
  711.   i: integer;
  712.   StrRect: TRect;
  713.   ADate: TDateTime;
  714.   AStrings: TStringList;
  715. begin
  716.   { don't try to draw strings if they're in row 0 }
  717.   if (ARow <> 0) then
  718.   begin
  719.     if (CellText[ACol, ARow] <> '') then
  720.     begin
  721.       { accept any strings assigned in the OnNeedStrings event }
  722.       ADate := EncodeDate(Year, Month, StrToInt(CellText[ACol, ARow]));
  723.       AStrings := FCalStrings[ACol, ARow];
  724.       if Assigned(FOnNeedStrings) then FOnNeedStrings(Self, ACol, ARow, ADate, AStrings);
  725.       if AStrings <> nil then FCalStrings[ACol, ARow] := AStrings;
  726.     end;
  727.     { color occupied cells }
  728.     if (FCalStrings[ACol, ARow] <> nil) and not (gdFocused in AState) then
  729.       Canvas.Brush.Color := clYellow;
  730.     inherited DrawCell(ACol, ARow, ARect, AState);
  731.     { don't try to draw strings if they're nil }
  732.     if FCalStrings[ACol, ARow] <> nil then
  733.     begin
  734.       Temp := FCalStrings[ACol, ARow];
  735.       for i := 0 to Temp.Count-1 do
  736.       begin
  737.         { set the clipping Rect }
  738.         StrRect := Rect(ARect.Left,ARect.Top+((i+1)*Canvas.TextHeight('Test')),
  739.           ARect.Right, ARect.Bottom);
  740.         { if there is room draw the lines }
  741.         if StrRect.Bottom-StrRect.Top >= Canvas.TextHeight('Test') then
  742.           Canvas.TextRect(StrRect, StrRect.Left + 1, StrRect.Top + 1, Temp.Strings[i]);
  743.       end;
  744.     end;
  745.   end else inherited DrawCell(ACol, ARow, ARect, AState);
  746. end;
  747.  
  748. { SetCellString - adds a string to the cells stringlist based on Col
  749.   or Row or Day of month. }
  750. procedure TStringsCalendar.SetCellString(ACol, ARow, ADay: Integer; Value: string);
  751. var
  752.   i, j: integer;
  753.   TheCellText: string;
  754. begin
  755.   if (not FUpdating) and (not FReadOnly) and (CellText[ACol, ARow] <> '') then
  756.   begin
  757.     { if ADay is being used calc ACol and ARow. Doesn't matter if
  758.       ACol and ARow are <> 0 we just calc them anyway }
  759.     if ADay <> 0 then
  760.     begin
  761.       for i := 0 to 6 do
  762.         for j := 1 to 6 do
  763.         begin
  764.           TheCellText := CellText[i, j];
  765.           if (TheCellText <> '') and (ADay = StrToInt(TheCellText)) then
  766.           begin
  767.             ACol := i;
  768.             ARow := j;
  769.           end;
  770.         end;
  771.     end;
  772.     { if no StringList assigned then create one }
  773.     if FCalStrings[ACol, ARow] = nil then
  774.       FCalStrings[ACol, ARow] := TStringList.Create;
  775.     { add the line of text }
  776.     FCalStrings[ACol, ARow].Add(Value);
  777.   end;
  778. end;
  779.  
  780. procedure TStringsCalendar.SetCalStrings(ACol, ARow: integer; Value: TStringList);
  781. begin  FCalStrings[ACol, ARow] := Value;end;{ GetCalStrings - allows access to cells stringlist object. Useful
  782.   for working with TList and TMemo }
  783. function TStringsCalendar.GetCalStrings(ACol, ARow: integer): TStringList;
  784. begin
  785.   { method to return StringList as an object }
  786.   Result := FCalStrings[ACol, ARow];
  787. end;
  788. { TRngSelCalendar }constructor TRngSelCalendar.Create(AOwner: TComponent);
  789. begin
  790.   inherited Create(AOwner);
  791.   { defaults }
  792.   FRangeColor := clBlue;
  793.   FStartDate := FDate;
  794.   FEndDate := FDate;
  795. end;
  796.  
  797. procedure TRngSelCalendar.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  798. begin
  799.   inherited MouseUp(Button, Shift, X, Y);
  800.   if Button = mbLeft then
  801.   begin
  802.     if not (ssShift in Shift) then
  803.     begin
  804.       FStartDate := FDate;
  805.       FEndDate := FDate;
  806.     end else FEndDate := FDate;
  807.   end;
  808.   if Assigned(FOnRngSelect) then FOnRngSelect(Self);
  809. end;
  810. procedure TRngSelCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);var
  811.   AYear, AMonth, ADay: Word;
  812.   TmpDate: TDateTime;
  813.   TheText: string;
  814. begin
  815.   TheText := CellText[ACol, ARow];
  816.   if (TheText <> '') and (ARow <> 0) then
  817.   begin
  818.     DecodeDate(FDate, AYear, AMonth, ADay);
  819.     TmpDate := EncodeDate(AYear, AMonth, StrToInt(TheText));
  820.     if (TmpDate >= FStartDate) and (TmpDate <= FEndDate)
  821.       and (FStartDate <> FEndDate) then
  822.         Canvas.Brush.Color := FRangeColor;
  823.   end;
  824.   inherited DrawCell(ACol, ARow, ARect, AState);
  825. end;
  826. procedure TRngSelCalendar.SetStartDate(Value: TDateTime);begin
  827.   if Value <> FStartDate then
  828.   begin
  829.     FStartDate := Value;
  830.     UpdateCalendar;
  831.   end;
  832. end;
  833.  
  834. procedure TRngSelCalendar.SetEndDate(Value: TDateTime);
  835. begin
  836.   if Value <> FEndDate then
  837.   begin
  838.     FEndDate := Value;
  839.     UpdateCalendar;
  840.   end;
  841. end;
  842. { TCalendarLabel }procedure TCalendarLabel.SetSource(Value: TStringsCalendar);begin
  843.   { set FCalendarSource := Value }
  844.   FCalendarSource := Value;
  845.   { if successful hook HookEvent }
  846.   if (FCalendarSource <> nil) then
  847.      FCalendarSource.HookEvent := DateChange;
  848.   { update label }
  849.   UpdateLabel;
  850. end;
  851.  
  852. procedure TCalendarLabel.Notification(AComponent: TComponent;
  853.       Operation: TOperation);
  854. begin
  855.   inherited Notification(AComponent, Operation);
  856.   { If the connected TBaseCalendar has been deleted, make the connection nil }
  857.   if (Operation = opRemove) and (AComponent = FCalendarSource) then
  858.      FCalendarSource := nil;
  859. end;
  860.  
  861. procedure TCalendarLabel.Loaded; 
  862. begin
  863.   inherited loaded;
  864.   { after loaded update label }
  865.   UpdateLabel;
  866. end;
  867.  
  868. procedure TCalendarLabel.DateChange(Sender: TObject);
  869. begin
  870.   { on HookEvent being triggered update label }
  871.   UpdateLabel;
  872. end;
  873.  
  874. procedure TCalendarLabel.UpdateLabel;
  875. begin
  876.   { change caption to new date }
  877.   if (FCalendarSource <> nil) then
  878.     Caption := FormatDateTime('mmmm dd, yyyy', FCalendarSource.CalendarDate);
  879. end;
  880. end.